home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
prog_d
/
isamexpt.zip
/
MYBUBBLE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-05
|
6KB
|
228 lines
unit MyBubble;
{$R-,W-,S-}
interface
uses
WinTypes, WinProcs, SysUtils, Messages, Classes, Controls,
Graphics, Forms, Dialogs, StdCtrls, ExtCtrls;
type
TBubble = class(THintWindow)
private
FDC, FCopyDC: HDC;
FCopyBitmap: HBitmap;
FOrigBrush1, FBrush1: HBrush;
FOrigBrush2, FBrush2: HBrush;
FRect: TRect;
FFlag: Boolean;
FTimerHandle: Word;
FTimerActive: Boolean;
procedure WMTimer(var Message: TWMTimer); message WM_TIMER;
public
Active: Boolean;
constructor Create(AOwner: TComponent); Override;
destructor Destroy; Override;
procedure ShowBubble(Rect: TRect; s1,s2: string);
end;
Var
Bubble : TBubble;
Procedure ShowBubble(AParent: TForm; R: TRect; aTime: Integer;
S1,S2: String);
Implementation
Uses UToolDll;
Const
BubbleShadow : Boolean = True;
var Zahl: Integer;
function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer;
Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean;
var
TempBitmap: HBitmap;
begin
Result := False;
CopyDC := 0;
CopyBitmap := 0;
if DC <> 0 then
begin
CopyDC := CreateCompatibleDC(DC);
if CopyDC <> 0 then
begin
CopyBitmap := CreateCompatibleBitmap(DC, Width, Height);
if CopyBitmap <> 0 then
begin
TempBitmap := CopyBitmap;
CopyBitmap := SelectObject(CopyDC, CopyBitmap);
Result := BitBlt(CopyDC, 0, 0, Width, Height, DC,
Left, Top, Rop);
CopyBitmap := TempBitmap;
end;
end;
end;
end;
function CopyBufToClip(DC: HDC; var CopyDC: HDC;
var CopyBitmap: HBitmap; Left, Top, Width, Height: Integer;
Rop: LongInt; DeleteObjects: Boolean): Boolean;
var
TempBitmap: HBitmap;
begin
Result := False;
if (DC <> 0) and (CopyDC <> 0) and (CopyBitmap <> 0) then
begin
TempBitmap := CopyBitmap;
CopyBitmap := SelectObject(DC, CopyBitmap);
Result := BitBlt(DC, Left, Top, Width, Height, CopyDC,
0, 0, Rop);
CopyBitmap := TempBitmap;
if DeleteObjects then
begin
DeleteDC(CopyDC);
DeleteObject(CopyBitmap);
end;
end;
end;
procedure TimerProc(Wnd: HWnd; Msg: Word; TimerID: Word;
SysTime: Longint); export;
begin
inc(Zahl);
if Zahl > 2 then begin
if Bubble <> NIL then Bubble.Free;
end;
end;
constructor TBubble.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Zahl:= 0;
Active:= True;
FDC := CreateDC('DISPLAY', '', '', nil);
FOrigBrush2 := CreateSolidBrush(RGB(0, 0, 0));
SetBkMode(FDC, TRANSPARENT);
SetTextColor(FDC, RGB(0, 0, 0));
FFlag := False;
FTimerHandle := SetTimer(Handle, 1, Application.HintPause, NIL);
FTimerActive := FTimerHandle > 0;
end;
procedure TBubble.WMTimer(var Message: TWMTimer);
begin
inc(Zahl);
if Zahl > 0 then Active:= False;
end;
destructor TBubble.Destroy;
begin
if FTimerActive then
begin
KillTimer(0, FTimerHandle);
FTimerActive := False;
end;
if FFlag then
CopyBufToClip(FDC, FCopyDC, FCopyBitmap, FRect.Left,
FRect.Top, FRect.Right-FRect.Left, FRect.Bottom-FRect.Top,
SRCCOPY, True);
DeleteObject(FOrigBrush2);
DeleteDC(FDC);
inherited Destroy;end;
procedure TBubble.ShowBubble(Rect: TRect; S1,s2: string);
var
Text: array[0..255] of Char;
TextExtent: LongInt;
TextWidth: Word;
s1Len,S2Len : Word;
WinWidth: Integer;
Factor: Integer;
Difference: Integer;
begin
BubbleShadow := True;
FOrigBrush1 := CreateSolidBrush(Application.HintColor);
FBrush1 := SelectObject(FDC, FOrigBrush1);
FRect := Rect;
TextExtent := GetTextExtent(FDC, StrPCopy(Text, s1), Length(S1));
TextWidth := TextExtent mod 65536;
FRect.Right := FRect.Left+TextWidth+40;
FRect.Left := FRect.Left-(TextWidth div 2);
FRect.Right := FRect.Right-(TextWidth div 2);
Factor := 80+(TextWidth div 6);
FRect.Bottom := FRect.Top+Factor;
if FRect.Left < 0 then
begin
Difference := -FRect.Left;
FRect.Left := FRect.Left+Difference;
FRect.Right := FRect.Right+Difference;
end;
if FRect.Top < 0 then
begin
Difference := -FRect.Top;
FRect.Top := FRect.Top+Difference;
FRect.Bottom := FRect.Bottom+Difference;
end;
if FRect.Right > Screen.Width then
begin
Difference := FRect.Right-Screen.Width;
FRect.Left := FRect.Left-Difference;
FRect.Right := FRect.Right-Difference;
end;
if FRect.Bottom > Screen.Height then
begin
Difference := FRect.Bottom-Screen.Height;
FRect.Top := FRect.Top-Difference;
FRect.Bottom := FRect.Bottom-Difference;
end;
FFlag := CopyClipToBuf(FDC, FRect.Left, FRect.Top,
FRect.Right-FRect.Left, FRect.Bottom-FRect.Top,
SRCCOPY, FCopyDC, FCopyBitmap);
if BubbleShadow then
begin
FBrush2 := SelectObject(FDC, FOrigBrush2);
Ellipse(FDC, FRect.Left, FRect.Top+20, FRect.Right, FRect.Bottom);
end;
FBrush1 := SelectObject(FDC, FOrigBrush1);
if BubbleShadow then
Ellipse(FDC, FRect.Left, FRect.Top+20, FRect.Right-4, FRect.Bottom-4)
else
Ellipse(FDC, FRect.Left, FRect.Top+20, FRect.Right, FRect.Bottom);
Ellipse(FDC, FRect.Left+((FRect.Right-FRect.Left) div 2)-7,
FRect.Top+8, FRect.Left+((FRect.Right-FRect.Left) div 2)+7,
FRect.Top+18);
Ellipse(FDC, FRect.Left+((FRect.Right-FRect.Left) div 2),
FRect.Top, FRect.Left+((FRect.Right-FRect.Left) div 2)+9,
FRect.Top+6);
TextOut(FDC, FRect.Left+15, FRect.Top+(Factor div 2)-5, StrPCopy(Text,S1),
Length(S1));
TextOut(FDC, FRect.Left+15, FRect.Top+7+(Factor div 2), StrPCopy(Text,S2),
Length(S2));
DeleteObject(FOrigBrush1);
Visible:= True;
end;
Procedure ShowBubble(AParent: TForm; R: TRect; aTime: Integer;
S1,S2: String);
begin
Bubble := TBubble.Create(AParent);
Try
Bubble.ShowBubble(R,S1,S2);
Finally
Repeat
Application.ProcessMessages;
Until Bubble.Active = False;
Bubble.Free;
end;
end;
end.